home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / os2 / lxlt113.zip / SOURCES / LXLITE.PAS < prev    next >
Pascal/Delphi Source File  |  1996-06-05  |  33KB  |  983 lines
  1. {$AlignCode-,AlignData-,AlignRec-,G3+,Speed-,Frame-}
  2. uses use32, exe386, os2base, strOp, miscUtil, Helpers, Country,
  3.      Strings, Dos, Crt;
  4.  
  5. label done;
  6.  
  7. const Version     = '1.1.3';
  8.       cfgFname    = 'lxLite.cfg';
  9.       logFname    = 'lxLite.log';
  10.      {-Configuration parameters-}
  11.       Verbose     : boolean = _OFF;
  12.       objUnpack   : boolean = _ON;
  13.       Backup      : boolean = _OFF;
  14.       Pause       : boolean = _OFF;
  15.       svFlags     : Longint = svfFOalnNone + svfEOalnShift;
  16.       pkFlags     : Longint = pkfLempelZiv;
  17.       doUnpack    : boolean = _OFF;
  18.       ForceRp     : boolean = _OFF;
  19.       ForceIdle   : boolean = _ON;
  20.       RealignB    : Byte = 2;
  21.       doWrite     : boolean = _ON;
  22.       ShowCfg     : boolean = _OFF;
  23.       rplStub     : boolean = _OFF;
  24.       Recurse     : boolean = _OFF;
  25.       QueryList   : boolean = _OFF;
  26.       stubName    : string = '';
  27.       excludeMask : string = '';
  28.       logFileName : string = '';
  29.       xdFileMask  : string = '';
  30.       ddFileMask  : string = '';
  31.       maxStubSz   : Longint = 1024;
  32.     {-Confirmation query subsystem constants-}
  33.       askInUse    = 1;
  34.       askExtraData= 2;
  35.       askOverBak  = 3;
  36.       askConfirm  = 4;
  37.       askDbgInfo  = 5;
  38.       askFirst    = askInUse;
  39.       askLast     = askDbgInfo;
  40.       AskStatus   : array[askFirst..askLast] of record
  41.                      ID    : char; {The /Y# character}
  42.                      Reply : char; {What to answer}
  43.                     end =
  44.                     ((ID : 'U'; Reply : #0),
  45.                      (ID : 'X'; Reply : 'D'),
  46.                      (ID : 'B'; Reply : 'N'),
  47.                      (ID : 'C'; Reply : #0),
  48.                      (ID : 'D'; Reply : 'Y'));
  49.  
  50. type  pMyLX = ^tMyLX;
  51.       tMyLX = object(tLX)
  52.        procedure   DisplayHeader;
  53.       end;
  54.  
  55. var   fNames,
  56.       pfNames,
  57.       loadCFG   : pDarray;
  58.       LX        : pMyLX;
  59.       totalGain : Longint;
  60.       newStub   : Pointer;
  61.       newStubSz : Longint;
  62.       allDone   : boolean;
  63.       oldExit   : Procedure;
  64.       exclude   : pFileMatch;
  65.       logFile   : Text;
  66.       Cntry     : pCountry;
  67.  
  68. procedure tMyLX.DisplayHeader;
  69. const
  70.      txtCPU  : array[lxCPU286..lxCPUP5] of string[8] =
  71.      ('i80286','i80386','i80486','Intel P5');
  72. var  S       : String;
  73.      I       : Longint;
  74.  
  75. procedure AddS(const nS : string);
  76. begin
  77.  if S <> '' then S := S + ', ';
  78.  S := S + nS;
  79. end;
  80.  
  81. begin
  82.  textAttr := $0B;
  83.  Writeln(#13'├');
  84.  textAttr := $0A;
  85.  S := '';
  86.  case Header.lxMFlags and lxModType of
  87.   lxEXE   : begin
  88.              AddS('executable');
  89.              case Header.lxMFlags and lxAppMask of
  90.               lxNoPMwin : AddS('not PM windowed');
  91.               lxPMwin   : AddS('PM windowed');
  92.               lxPMapi   : AddS('PM application');
  93.               else AddS('unknown API type');
  94.              end;
  95.             end;
  96.   lxDLL,
  97.   lxPMDLL,
  98.   lxPDD,
  99.   lxVDD   : begin
  100.              case Header.lxMFlags and lxModType of
  101.               lxDLL   : AddS('DLL');
  102.               lxPMDLL : AddS('protmode DLL');
  103.               lxPDD   : AddS('PDD');
  104.               lxVDD   : AddS('VDD');
  105.              end;
  106.              if Header.lxMFlags and lxLibInit <> 0
  107.               then AddS('per-process Init');
  108.              if Header.lxMFlags and lxLibTerm <> 0
  109.               then AddS('per-process Term');
  110.             end;
  111.   else AddS('unknown module type');
  112.  end;
  113.  if Header.lxMFlags and lxNoIntFix <> 0
  114.   then AddS('no internal fixups');
  115.  if Header.lxMFlags and lxNoExtFix <> 0
  116.   then AddS('no external fixups');
  117.  if Header.lxMFlags and lxNoLoad <> 0
  118.   then AddS('not loadable');
  119.  Writeln('├ Module type:  ', S);
  120.  Writeln('├ Required CPU: ', txtCPU[Header.lxCpu]:10, '   ',
  121.            'Version:      ', long2str(Header.lxVer shr 16) + '.' + sstr(SmallWord(Header.lxVer), 2, '0'):10);
  122.  Writeln('├ Page size:    ', Header.lxPageSize:10, '   ',
  123.            'Page shift:   ', Header.lxPageShift:10);
  124.  Writeln('├ Objects:      ', Header.lxObjCnt:10, '   ',
  125.            'Resources:    ', Header.lxRsrcCnt:10);
  126.  Writeln('├ Imported entries:', Header.lxImpModCnt:7, '   ',
  127.            'Debug info,b: ', Header.lxDebugLen:10);
  128.  Writeln('├ Start ObjID:EIP: ', Header.lxStartObj,':',Hex8(Header.lxEIP));
  129.  Writeln('├ Stack ObjID:ESP: ', Header.lxStackObj,':',Hex8(Header.lxESP));
  130.  For i := 1 to ResNameTbl^.numItems do
  131.   with pNameTblRec(ResNameTbl^.GetItem(I))^ do
  132.    if Ord = 0
  133.     then Writeln('├ Module name:     ', Name^);
  134.  For i := 1 to NResNameTbl^.numItems do
  135.   with pNameTblRec(NResNameTbl^.GetItem(I))^ do
  136.    if Ord = 0
  137.     then Writeln('├ Description:     ', Name^);
  138.  Write('└  ');
  139. end;
  140.  
  141. Procedure Stop(eCode : Byte);
  142.  
  143. Procedure Pause;
  144. begin
  145.  if not RedirOutput
  146.   then begin
  147.         textAttr := $01; Write(Strg(' ', 30), 'Press any key ... '); Readkey;
  148.         Write(#13); textAttr := $07; ClrEOL;
  149.        end;
  150. end;
  151.  
  152. begin
  153.  Write(#13);
  154.  case eCode of
  155.   1,2 : begin
  156.          if eCode = 2
  157.           then begin
  158.                 TextAttr := 12;
  159.                 Writeln('├ Invalid switch - see help below for details');
  160.                end;
  161.          TextAttr := 7;
  162.          Writeln('├ Usage: lxLite [FileMask1] {...FileMask2} {/ABCDEFIMPQRSTUVWXZH?}');
  163.          Writeln('├ /A{P|S|N{P|S}}');
  164.          Writeln('│  Set alignment for first/rest of objects. First object can be aligned');
  165.          Writeln('│  on [P]age shift, [S]ector or [N]o boundary. For rest you cannot use N');
  166.          Writeln('├ /B{+|-} Enable (+) or disable (-) renaming of original file into .BAK');
  167.          Writeln('├ /C{#}   Use configuration with given (#) identifier (see /Q)');
  168.          Writeln('├ /D{#}   Set exclu[D]e filemasks. Skip files that fit in given filemask');
  169.          Writeln('├ /E{+|-} r[E]cursive (+) file search through subdirectories');
  170.          Writeln('├ /F{+|-} Force (+) or don`t force (-) repacking. Use to bypass autodetection');
  171.          Writeln('├ /G[X|D]#Extra/debug data [G]oes into another file. (#) is an OS/2 filemask');
  172.          Writeln('├ /I{+|-} Run lxLite at [I]dle (+) or at normal (-) priority');
  173.          Writeln('├ /L{#}   Set [L]og filename. If no filename is specified, lxLite.log is used');
  174.          Writeln('├ /M{R{N|1|2|3}|L{N|1}} Set packing method & parameters:');
  175.          Writeln('│  R = run-length (/EXEPACK:1); [N]one or level [1],[2],[3] (3=max comp. lvl)');
  176.          Writeln('│  L - kinda Lempel-Ziv (/EXEPACK:2); [N]one or level [1] (always the best)');
  177.          Writeln('├ /P{+|-} Enable (+) or disable (-) pause before each file');
  178.          Writeln('├ /Q{+|-} [Q]uery configuration options (/C#). Shows a list of cfg names.');
  179.          Writeln('├ /R{#}   [R]e-align pages on specific boundary. (#) must be a power of two');
  180.          Writeln('├ /S{+|-} Show (+) or don`t show (-) current configuration (useful with /C#)');
  181.          Writeln('├ /T{#}   Replace DOS stub by that contained in file #. Use /T to remove stub');
  182.          Pause;
  183.          Writeln('├ /U{+|-} Enable (+) or disable (-) unpacking file before packing');
  184.          Writeln('├ /V{+|-} Verbose (show a lot of additional file information)');
  185.          Writeln('├ /W{+|-} Enable (+) or disable (-) writing of resulting file');
  186.          Writeln('├ /X{+|-} e[X]pand given files');
  187.          Writeln('├ /Y{#{?} auto-repl[Y] "?" on question about # or Ask if ? is missing');
  188.          Writeln('├ /Z{#}   Set stub size threshold: if stubSize > # then don`t replace it');
  189.          Writeln('├ /?,/H   Show this help screen');
  190.          Writeln('├┤Default: /ANP /B- /Cdefault /D+ /E- /F- /G /I+ /MRN /ML1 /O256 /P- /Q-');
  191.          Writeln('│          /R4 /S- /T{disabled} /U+ /V- /W+ /X- /YBN /YDD /YXD /Z1024');
  192.          TextAttr := $08;
  193.          Writeln('└┤Example: lxLite *.exe *.dll *.fon *.sys *.pdr /e /d+ /p+ /ass');
  194.         end;
  195.   3   : Writeln('└┤Invalid entry in configuration file');
  196.   4   : Writeln('└┤Cannot load DOS stub replacement ', stubName);
  197.   5   : Writeln('└┤Fatal disk I/O error: cannot continue');
  198.   6   : Writeln('└┤Invalid stub format: not a DOS .EXE file');
  199.   7   : Writeln('└┤Failed to open configuration file');
  200.   8   : Writeln('└┤Failed to open log file ', logFileName);
  201.   9   : Writeln('└┤Cannot get country information');
  202.   10  : Writeln('└┤Option /G?#: Cannot conert filename using given filemask');
  203.   11  : Writeln('└┤Option /G?#: Xtra/debug filename equals executable filename');
  204.   12  : Writeln('└┤Cannot open file for xtra/debug data');
  205.  end;
  206.  Halt(eCode);
  207. end;
  208.  
  209. Procedure LoadConfig(const ID : string); forward;
  210. var Ch : Char;
  211.  
  212. Function ParmHandler(var S : string) : Byte;
  213. var I : Longint;
  214.  
  215. Function Enabled : boolean;
  216. begin
  217.  Enabled := _ON;
  218.  if length(S) = 1
  219.   then exit
  220.   else
  221.  if (S[2] in ['+','-'])
  222.   then ParmHandler := 2
  223.   else
  224.  if (S[2] in [' ','/'])
  225.   then exit
  226.   else Stop(2);
  227.  if S[2] = '-' then Enabled := _OFF;
  228. end;
  229.  
  230. begin
  231.  ParmHandler := 1;
  232.  case upCase(S[1]) of
  233.   '?',
  234.   'H' : Stop(1);
  235.   'A' : if length(S) > 1
  236.          then begin
  237.                svFlags := svFlags and (not svfAlignFirstObj);
  238.                case upCase(S[2]) of
  239.                 'N' : svFlags := svFlags or svfFOalnNone;
  240.                 'P' : svFlags := svFlags or svfFOalnShift;
  241.                 'S' : svFlags := svFlags or svfFOalnSector;
  242.                 else Stop(2);
  243.                end;
  244.                ParmHandler := 2;
  245.                if length(S) > 2
  246.                 then begin
  247.                       svFlags := svFlags and (not svfAlignEachObj);
  248.                       case upCase(S[3]) of
  249.                        'P' : svFlags := svFlags or svfEOalnShift;
  250.                        'S' : svFlags := svFlags or svfEOalnSector;
  251.                        else Stop(2);
  252.                       end;
  253.                       ParmHandler := 3;
  254.                      end;
  255.               end;
  256.   'C' : begin
  257.          Delete(S, 1, 1);
  258.          I := 0; While (I < length(S)) and (S[I + 1] > ' ') do Inc(I);
  259.          LoadConfig(Copy(S, 1, I));
  260.          ParmHandler := I;
  261.         end;
  262.   'R' : begin
  263.          Delete(S, 1, 1);
  264.          I := DecVal(S);
  265.          if I <> 0
  266.           then RealignB := BitSR(I)
  267.           else RealignB := 255;
  268.          ParmHandler := 0;
  269.          if not (RealignB in [0..12,255]) then Stop(2);
  270.         end;
  271.   'T' : begin
  272.          Delete(S, 1, 1);
  273.          I := 0; While (I < length(S)) and (S[I + 1] > ' ') do Inc(I);
  274.          stubName := Copy(S, 1, I); rplStub := _ON;
  275.          ParmHandler := I;
  276.         end;
  277.   'M' : if length(S) > 1
  278.          then case upCase(S[2]) of
  279.                'R' : begin
  280.                       ParmHandler := 3;
  281.                       pkFlags := pkFlags and not (pkfRunLength or pkfRunLengthLvl);
  282.                       if length(S) > 2
  283.                        then case upCase(S[3]) of
  284.                              '1' : pkFlags := pkFlags or pkfRunLength or pkfRunLengthMin;
  285.                              '2' : pkFlags := pkFlags or pkfRunLength or pkfRunLengthMid;
  286.                              '3' : pkFlags := pkFlags or pkfRunLength or pkfRunLengthMax;
  287.                              'N' : ;
  288.                              else Stop(2);
  289.                             end
  290.                        else Stop(2);
  291.                      end;
  292.                'L' : begin
  293.                       ParmHandler := 3;
  294.                       if length(S) > 2
  295.                        then case upCase(S[3]) of
  296.                              '1' : pkFlags := pkFlags or pkfLempelZiv;
  297.                              'N' : pkFlags := pkFlags and not pkfLempelZiv;
  298.                              else Stop(2);
  299.                             end
  300.                        else Stop(2);
  301.                      end
  302.                else Stop(2);
  303.               end
  304.          else Stop(2);
  305.   'D' : begin
  306.          Delete(S, 1, 1);
  307.          I := 0; While (I < length(S)) and (S[I + 1] > ' ') do Inc(I);
  308.          if I = 0
  309.           then excludeMask := ''
  310.           else excludeMask := excludeMask + Copy(S, 1, I);
  311.          ParmHandler := I;
  312.         end;
  313.   'L' : begin
  314.          Delete(S, 1, 1);
  315.          I := 0; While (I < length(S)) and (S[I + 1] > ' ') do Inc(I);
  316.          if I >= 1
  317.           then logFileName := Copy(S, 1, I)
  318.           else logFileName := sourcePath + logFname;
  319.          ParmHandler := I;
  320.         end;
  321.   'G' : begin
  322.          Delete(S, 1, 1);
  323.          if (S = '') or (not (upCase(S[1]) in ['D','X'])) then Stop(2);
  324.          I := 1; While (I < length(S)) and (S[I + 1] > ' ') do Inc(I);
  325.          case upCase(S[1]) of
  326.           'D' : ddFileMask := Copy(S, 2, pred(I));
  327.           'X' : xdFileMask := Copy(S, 2, pred(I));
  328.          end;
  329.          ParmHandler := I;
  330.         end;
  331.   'B' : Backup := Enabled;
  332.   'F' : ForceRp := Enabled;
  333.   'I' : ForceIdle := Enabled;
  334.   'E' : Recurse := Enabled;
  335.   'Q' : QueryList := Enabled;
  336.   'S' : ShowCfg := Enabled;
  337.   'U' : objUnpack := Enabled;
  338.   'P' : Pause := Enabled;
  339.   'V' : Verbose := Enabled;
  340.   'W' : doWrite := Enabled;
  341.   'X' : begin
  342.          doUnpack := Enabled;
  343.          if doUnpack then LoadConfig('unpack');
  344.         end;
  345.   'Y' : if (length(S) > 1) and (S[2] > ' ')
  346.          then begin
  347.                ParmHandler := 2;
  348.                For I := askFirst to askLast do {Enable all queries}
  349.                 with AskStatus[I] do
  350.                  if UpCase(S[2]) = ID
  351.                   then begin
  352.                         if (length(S) > 2) and (S[3] > ' ')
  353.                          then begin
  354.                                Reply := S[3];
  355.                                ParmHandler := 3;
  356.                               end
  357.                          else Reply := #0;
  358.                         exit;
  359.                        end;
  360.                Stop(2);
  361.               end
  362.          else For I := askFirst to askLast do {Enable all queries}
  363.                AskStatus[I].Reply := #0;
  364.   'Z' : begin
  365.          Delete(S, 1, 1);
  366.          if (S <> '') and (S[1] in ['0'..'9'])
  367.           then maxStubSz := DecVal(S)
  368.           else maxStubSz := $7FFFFFFF;
  369.         end;
  370.   else Stop(2);
  371.  end;
  372. end;
  373.  
  374. Function NameHandler(var S : string) : Byte;
  375. var I     : Longint;
  376.     Quote : boolean;
  377. begin
  378.  I := 0;
  379.  if S[1] = '"' then begin Quote := _ON; Delete(S, 1, 1); end else Quote := _OFF;
  380.  While (I < length(S)) and ((S[succ(I)] > ' ') or Quote) do
  381.   if Quote and (S[succ(I)] = '"')
  382.    then break
  383.    else Inc(I);
  384.  fNames^.AddItem(NewStr(Copy(S, 1, I)));
  385.  Inc(I, byte(Quote));
  386.  NameHandler := I;
  387. end;
  388.  
  389. Procedure ShowConfigList;
  390. var T   : Text;
  391.     S,W : String;
  392.     I   : Longint;
  393. begin
  394.  Assign(T, sourcePath + cfgFname); Reset(T);
  395.  if ioResult <> 0 then Stop(7);
  396.  While not SeekEOF(T) do
  397.   begin
  398.    Readln(T, S);
  399.    if First(';', S) > 0 then Delete(S, First(';', S), 255);
  400.    DelStartSpaces(S);
  401.    if S = '' then continue;
  402.    I := First(':', S); if I = 0 then Stop(3);
  403.    W := Copy(S, 1, pred(I));
  404.    While (W[length(W)] = ' ') do Dec(byte(W[0]));
  405.    if length(W) < 10 then W := W + Strg(' ', 10 - length(W));
  406.    S := Copy(S, succ(I), 255); DelStartSpaces(S);
  407.    textAttr := $07; Write('├┤');
  408.    textAttr := $0A; Write(W);
  409.    textAttr := $02; Writeln(S);
  410.   end;
  411. end;
  412.  
  413. Procedure LoadConfig;
  414. var T : Text;
  415.     S : String;
  416.     I : Longint;
  417.     W : boolean;
  418. begin
  419.  For I := 1 to loadCFG^.numItems do
  420.   if pString(loadCFG^.GetItem(I))^ = upStrg(ID) then exit; {already}
  421.  loadCFG^.AddItem(NewStr(upStrg(ID)));
  422.  Assign(T, sourcePath + cfgFname); Reset(T);
  423.  if ioResult <> 0 then Stop(7);
  424.  W := _OFF;
  425.  While not SeekEOF(T) do
  426.   begin
  427.    Readln(T, S);
  428.    if First(';', S) > 0 then Delete(S, First(';', S), 255);
  429.    DelStartSpaces(S);
  430.    if S = '' then continue;
  431.    if First(':', S) = 0 then Stop(3);
  432.    if upStrg(Copy(S, 1, pred(First(':', S)))) = upStrg(ID)
  433.     then begin
  434.           Delete(S, 1, First(':', S));
  435.           ParseCommandLine(S, ParmHandler, NameHandler);
  436.           W := _ON; break;
  437.          end;
  438.   end;
  439.  if not W
  440.   then begin
  441.         textAttr := $0C;
  442.         Writeln('├ Failed to load configuration record [', Copy(ID, 1, 20), ']');
  443.        end;
  444.  inOutRes := 0; Close(T); inOutRes := 0;
  445. end;
  446.  
  447. Procedure ShowConfig;
  448. const ONOFF : array[boolean] of string[3] = ('OFF', 'ON');
  449. begin
  450.  textAttr := $0B;
  451.  Writeln('├ ═══════════ lxLite configuration: ═══════════');
  452.  textAttr := $03;
  453.  Writeln('├ Verbose:                  ', ONOFF[Verbose]);
  454.  Writeln('├ Run at idle priority:     ', ONOFF[ForceIdle]);
  455.  Writeln('├ Unpack loaded executable: ', ONOFF[objUnpack]);
  456.  Writeln('├ Backup executables:       ', ONOFF[Backup]);
  457.  Writeln('├ Pause before each file:   ', ONOFF[Pause]);
  458.  if rplStub
  459.   then begin
  460.         Write('├ Replace DOS stub by:      ');
  461.         if stubName <> ''
  462.          then Writeln(Copy(stubName, 1, 50))
  463.          else Writeln('remove it');
  464.        end;
  465.  Write  ('├ Align first object:       ');
  466.  case svFlags and svfAlignFirstObj of
  467.   svfFOalnNone   : Writeln('No');
  468.   svfFOalnShift  : Writeln('on PageShift bound');
  469.   svfFOalnSector : Writeln('on sector bound');
  470.  end;
  471.  Write  ('├ Align other objects:      ');
  472.  case svFlags and svfAlignEachObj of
  473.   svfEOalnShift  : Writeln('on PageShift bound');
  474.   svfEOalnSector : Writeln('on sector bound');
  475.  end;
  476.  Write  ('├ Realign executable pages: ');
  477.  if RealignB = 255
  478.   then Writeln('don`t change')
  479.   else Writeln('on ', 1 shl RealignB, ' boundary');
  480.  if not doUnpack
  481.   then begin
  482.         Write  ('├ Run-length packing:       ');
  483.         if pkFlags and pkfRunLength <> 0
  484.          then case pkFlags and pkfRunLengthLvl of
  485.                pkfRunLengthMin : Writeln('Minimal (find 1-byte sequences)');
  486.                pkfRunLengthMid : Writeln('Middle (up to 16-byte sequences)');
  487.                pkfRunLengthMax : Writeln('Maximal (find ALL sequences (SLOW!!!))');
  488.               end
  489.          else Writeln('Disabled');
  490.         Write  ('├ Lempel-Ziv packing:       ');
  491.         if pkFlags and pkfLempelZiv <> 0
  492.          then Writeln('Enabled')
  493.          else Writeln('Disabled');
  494.        end;
  495.  if excludeMask <> ''
  496.   then Writeln('├ Excluded files mask:      ', excludeMask);
  497. end;
  498.  
  499. Procedure MyExitProc;
  500. begin
  501.  if TextRec(logFile).Handle <> 0 then Close(logFile);
  502.  Write(#13);
  503.  TextAttr := $07; ClrEOL;
  504.  OldExit;
  505. end;
  506.  
  507. Function CheckError(ec : byte) : boolean;
  508. begin
  509.  textAttr := $0C;
  510.  case ec of
  511.   lxeReadError     : Write('error reading executable');
  512.   lxeWriteError    : Write('error writing executable');
  513.   lxeBadFormat     : Write('invalid executable file format');
  514.   lxeBadRevision   : Write('unsupported executable format revision');
  515.   lxeBadOrdering   : Write('invalid word/dword ordering in executable');
  516.   lxeInvalidCPU    : Write('executable target is an unsupported CPU type');
  517.   lxeBadOS         : Write('executable target is an unsupported OS');
  518.   lxeUnkEntBundle  : Write('unknown entry bundle type in executable');
  519.   lxeUnkPageFlags  : Write('unknown page flags in executable');
  520.   lxeInvalidPage   : Write('invalid object page detected in executable');
  521.   lxeNoMemory      : Write('not enough memory to load executable');
  522.   lxeInvalidStub   : Write('invalid stub');
  523.   lxeEAreadError   : Write('error reading EAs');
  524.   lxeEAwriteError  : Write('error writing EAs');
  525.  end;
  526.  if ec <> lxeOK
  527.   then begin
  528.         textAttr := $0B; Writeln(#13'├');
  529.         CheckError := _ON;
  530.        end
  531.   else CheckError := _OFF;
  532. end;
  533.  
  534. var prevProgressValue : Longint;
  535.  
  536. function showProgress(Current,Max : Longint) : boolean;
  537. var S   : string;
  538.     val : Longint;
  539. begin
  540.  S := Strg('▒', 20);
  541.  val := Current * 20 div Max;
  542.  if val <> prevProgressValue
  543.   then begin
  544.         FillChar(S[1], val, '█');
  545.         textAttr := $03;
  546.         Write(S,']' + Strg(#8, length(S) + 2) + '[');
  547.         prevProgressValue := val;
  548.        end;
  549. end;
  550.  
  551. Function Ask(const Q,A : string; qNo : byte) : byte;
  552. var ch : char;
  553.     N  : Integer;
  554. begin
  555.  ch := AskStatus[qNo].Reply;
  556.  N := First(upCase(ch), A);
  557.  if N <> 0 then begin Ask := N; exit; end;
  558.  TextAttr := $02;
  559.  Write('└ ', Q, ' ');
  560.  repeat
  561.   ch := upCase(ReadKey);
  562.   if First(ch, A) <> 0
  563.    then begin
  564.          Ask := First(ch, A);
  565.          break;
  566.         end;
  567.  until _OFF;
  568.  Writeln(Ch, #13'├');
  569. end;
  570.  
  571. var askU : byte;
  572.  
  573. Function CheckUseCount(fName : string) : boolean;
  574. var F : File;
  575.     I : Longint;
  576. begin
  577.  CheckUseCount := _OFF; askU := 0;
  578.  I := FileMode; FileMode := open_access_ReadWrite or open_share_DenyReadWrite;
  579.  Assign(F, fName); SetFattr(F, Archive);
  580.  Reset(F, 1); Close(F); FileMode := I;
  581.  if ioResult = 0 then exit;
  582.  textAttr := $0E;
  583.  Writeln('├ The module ' + Copy(fName, 1, 40) + ' is used by another process');
  584.  CheckUseCount := _ON;
  585.  askU := Ask('[R]eplace, [S]kip or [A]bort?', 'RSA', askInUse);
  586.  case askU of
  587.   1 : ;
  588.   2 : exit;
  589.   3 : begin allDone := _ON; exit; end;
  590.  end;
  591.  fName := fName + #0;
  592.  if DosReplaceModule(@fName[1], nil, nil) <> 0
  593.   then begin
  594.         textAttr := $0C;
  595.         Writeln('├ Cannot replace module ' + fName);
  596.         exit;
  597.        end;
  598.  CheckUseCount := _OFF;
  599. end;
  600.  
  601. Procedure StoreData(const fName,fMask : string; var destF : string;
  602.                     var Buff; BuffSize : Longint);
  603. var Source,
  604.     Mask,
  605.     Target : array[0..255] of Char;
  606.     F      : File;
  607.     _d     : DirStr;
  608.     _n     : NameStr;
  609.     _e     : ExtStr;
  610.  
  611. begin
  612.  if fMask = '' then Exit;
  613.  fSplit(fName, _d, _n, _e);
  614.  StrPcopy(Source, _n + _e);
  615.  StrPcopy(Mask, fMask);
  616.  if DosEditName(1, Source, Mask, Target, sizeOf(Target)) <> 0 then Stop(10);
  617.  if StrComp(Source, Target) = 0 then Stop(11);
  618.  destF := _d + StrPas(Target);
  619.  Assign(F, destF); Rewrite(F, 1);
  620.  if ioResult <> 0 then Stop(12);
  621.  BlockWrite(F, Buff, BuffSize);
  622.  inOutRes := 0; Close(F); inOutRes := 0;
  623. end;
  624.  
  625. Procedure ProcessFile(fName : string);
  626. label SaveLX;
  627. var   _d    : DirStr;
  628.       _n    : NameStr;
  629.       _e    : ExtStr;
  630.       bk,
  631.       dbgOut,
  632.       xtrOut: string;
  633.       ss,fs : Longint;
  634.       askD,
  635.       askX,
  636.       askB  : Byte;
  637.  
  638. Procedure TrackProcess;
  639. begin
  640.  textAttr := $0B; Write(#13); ClrEOL;
  641.  Write('└ Processing file ', Copy(_n + _e, 1, 28) + '  ');
  642. end;
  643.  
  644. begin
  645.  fSplit(fName, _d, _n, _e);
  646.  if exclude^.Matches(_n + _e) then Exit;
  647.  TrackProcess;
  648.  askD := 0; askX := 0; askB := 0; askU := 0; dbgOut := ''; xtrOut := '';
  649.  if CheckError(LX^.Load(fName)) then exit;
  650.  if LX^.Header.lxDebugLen > 0
  651.   then begin
  652.         Write(#13); ClrEOL;
  653.         textAttr := $0E;
  654.         Writeln('├ The file ' + Copy(_n + _e, 1, 28) + ' contains ' + long2str(LX^.Header.lxDebugLen) +
  655.                 ' bytes of debug information');
  656.         askD := Ask('[D]iscard or [L]eave them, [S]kip file or [A]bort ?', 'DLSA', askDbgInfo);
  657.         case askD of
  658.          1 : with LX^ do
  659.               if Header.lxDebugInfoOfs <> 0
  660.                then begin
  661.                      StoreData(fName, ddFileMask, dbgOut, DebugInfo, Header.lxDebugLen);
  662.                      FreeMem(DebugInfo, Header.lxDebugLen);
  663.                      Header.lxDebugInfoOfs := 0;
  664.                      Header.lxDebugLen := 0;
  665.                     end;
  666.          3 : exit;
  667.          4 : begin allDone := _ON; exit; end;
  668.         end;
  669.         TrackProcess;
  670.        end;
  671.  if (not ForceRp) and (LX^.isPacked(realignB, newStubSz, pkFlags, svFlags))
  672.   then begin
  673.         Write('already processed'); textAttr := $0B; Writeln(#13'├');
  674.         exit;
  675.        end;
  676.  with LX^ do
  677.   if OverlaySize <> 0
  678.    then begin
  679.          Write(#13); ClrEOL;
  680.          textAttr := $0E;
  681.          Writeln('├ The file ' + Copy(_n + _e, 1, 28) + ' contains ' + long2str(OverlaySize) +
  682.                  ' bytes of data out of LX structure');
  683.          Write('├ It is possible that resulting file will be non-functional');
  684.          askX := Ask('[D]iscard or [L]eave them, [S]kip file or [A]bort ?', 'DLSA', askExtraData);
  685.          case askX of
  686.           1 : begin
  687.                StoreData(fName, xdFileMask, xtrOut, Overlay, OverlaySize);
  688.                FreeMem(Overlay, OverlaySize);
  689.                OverlaySize := 0;
  690.               end;
  691.           3 : exit;
  692.           4 : begin allDone := _ON; exit; end;
  693.          end;
  694.          TrackProcess;
  695.         end;
  696.  if rplStub and (LX^.StubSize <= maxStubSz) and (newStubSz <> -1)
  697.   then with LX^ do
  698.         begin
  699.          FreeMem(Stub, StubSize);
  700.          GetMem(Stub, NewStubSz);
  701.          Move(NewStub^, Stub^, NewStubSz);
  702.          StubSize := NewStubSz;
  703.         end;
  704.  ss := FileLength(fName);
  705.  if Verbose then LX^.DisplayHeader;
  706.  if RealignB <> 255 then LX^.Header.lxPageShift := RealignB;
  707.  if objUnpack then LX^.Unpack;
  708.  if not doUnpack
  709.   then begin
  710.         prevProgressValue := -1;
  711.         LX^.Pack(pkFlags, showProgress);
  712.        end;
  713.  Write(#13); ClrEOL;
  714.  if not doWrite then exit;
  715.  if CheckUseCount(fName) then exit;
  716.  bk := _d + _n + '.bak';
  717.  if FileExist(bk)
  718.   then begin
  719.         textAttr := $0E;
  720.         Writeln('├ The file ' + bk + ' already exists.');
  721.         askB := Ask('[O]verwrite .BAK/[N]o backup/[S]kip file or [A]bort?', 'ONSA', askOverBak);
  722.         case askB of
  723.          1 : FileErase(bk);
  724.          2 : goto SaveLX;
  725.          3 : exit;
  726.          4 : begin allDone := _ON; exit; end;
  727.         end;
  728.        end;
  729.  textAttr := $0B; Write('└ Backing up  ', Copy(_n + _e, 1, 28) + ' ... ');
  730.  if not FileCopy(fName, bk)
  731.   then begin
  732.         textAttr := $0C; Write('error during copy');
  733.         textAttr := $0B; Writeln(#13'├');
  734.         exit;
  735.        end;
  736.  Write(#13); ClrEOL;
  737. SaveLX:
  738.  textAttr := $0B; Write('└ Saving file ', Copy(_n + _e, 1, 28) + ' ... ');
  739.  if CheckError(LX^.Save(fName, svFlags))
  740.   then begin
  741.         if not FileCopy(bk, fName) then Stop(5);
  742.         FileErase(bk);
  743.         exit;
  744.        end;
  745.  if not Backup then FileErase(bk);
  746.  Write(#13); ClrEOL;
  747.  fs := FileLength(fName);
  748.  textAttr := $0B;
  749.  _d := long2str(1000 - (fs * 1000) div ss);
  750.  If (length(_d) < 2 + byte(_d[1] = '-'))
  751.   then Insert('0.', _d, length(_d))
  752.   else Insert('.', _d, length(_d));
  753.  Writeln('├', Copy(_n + _e, 1, 28):28, ' initial:',
  754.        SStr(ss, 8, ' '), ' final:', SStr(fs, 8, ' '),
  755.        ' gain: ', _d, '%');
  756.  Inc(totalGain, ss - fs);
  757.  
  758.  if logFileName <> ''
  759.   then begin
  760.         Writeln(logFile, Cntry^.TimeStr(toStdTimeL),
  761.                 ' File: ', fName, Strg(' ', 20 - length(fName)),
  762.                 ' initial:', SStr(ss, 8, ' '), ' final:', SStr(fs, 8, ' '),
  763.                 ' gain: ', _d, '%');
  764.         case askD of
  765.          1 : if dbgOut <> ''
  766.               then Writeln(logFile, Strg(' ', 9), 'Debug info has been placed into ', dbgOut)
  767.               else Writeln(logFile, Strg(' ', 9), 'Debug info has been removed from output file');
  768.          2 : Writeln(logFile, Strg(' ', 9), 'Debug info has been re-stored into output file');
  769.         end;
  770.         case askX of
  771.          1 : if xtrOut <> ''
  772.               then Writeln(logFile, Strg(' ', 9), 'Extra LX data has been placed into ', xtrOut)
  773.               else Writeln(logFile, Strg(' ', 9), 'Extra LX data has been removed from output file');
  774.          2 : Writeln(logFile, Strg(' ', 9), 'Extra LX data has been re-stored into output file');
  775.         end;
  776.         case askB of
  777.          1 : Writeln(logFile, Strg(' ', 9), '.BAK file already existed and has been overwritten');
  778.          2 : Writeln(logFile, Strg(' ', 9), '.BAK file already existed and left as-is');
  779.         end;
  780.         case AskU of
  781.          1 : Writeln(logFile, Strg(' ', 9), 'Executable has been used by another process and replaced');
  782.         end;
  783.        end;
  784. end;
  785.  
  786. Procedure freeFnames;
  787. var i : SmallInt;
  788. begin
  789.  For i := 1 to fNames^.numItems do
  790.   DisposeStr(fNames^.GetItem(I));
  791.  fNames^.Clear;
  792. end;
  793.  
  794. Procedure clearProcessed;
  795. var i : longint;
  796. begin
  797.  For I := 1 to pfNames^.NumItems do
  798.   DisposeStr(pfNames^.GetItem(I));
  799.  pfNames^.Clear;
  800. end;
  801.  
  802. Function CheckIfProcessed(const fName : string) : boolean;
  803. var i : longint;
  804.     s : String;
  805. begin
  806.  CheckIfProcessed := _ON;
  807.  s := lowStrg(fExpand(fName));
  808.  For I := 1 to pfNames^.numItems do
  809.   if pString(pfNames^.GetItem(I))^ = s
  810.    then exit;
  811.  pfNames^.AddItem(NewStr(s));
  812.  CheckIfProcessed := _OFF;
  813. end;
  814.  
  815. Procedure LoadStub;
  816. type
  817.     pDosEXEheader = ^tDosEXEheader;
  818.     tDosEXEheader = record
  819.      ID        : SmallWord;
  820.      PartPage  : SmallWord;
  821.      PageCount : SmallWord;
  822.      ReloCount : SmallWord;
  823.      HeaderSize: SmallWord;
  824.      MinAlloc  : SmallWord;
  825.      MaxAlloc  : SmallWord;
  826.      InitSS    : SmallWord;
  827.      InitSP    : SmallWord;
  828.      CheckSum  : SmallWord;
  829.      InitIP    : SmallWord;
  830.      InitCS    : SmallWord;
  831.      RelTblOfs : SmallWord;
  832.      Overlay   : SmallWord;
  833.      dummy     : array[1..16] of SmallWord;
  834.      ExtHdrOfs : Longint;
  835.     end;
  836. var F    : File;
  837.     EH   : pDosEXEheader;
  838.     P    : pArrOfByte;
  839.     S,hS : Longint;
  840. begin
  841.  if (not rplStub) then begin NewStubSz := -1; exit; end;
  842.  if (stubName = '') then exit;
  843.  Assign(F, stubName); Reset(F, 1);
  844.  if ioResult <> 0
  845.   then begin Assign(F, SourcePath + stubName); Reset(F, 1); end;
  846.  if ioResult <> 0 then Stop(4);
  847.  newStubSz := FileSize(F);
  848.  GetMem(newStub, newStubSz);
  849.  BlockRead(F, newStub^, newStubSz);
  850.  Close(F);
  851.  if ioResult <> 0 then Stop(4);
  852.  EH := newStub;
  853.  with EH^ do
  854.   begin
  855.    if (ID <> $4D5A) and (ID <> $5A4D) then Stop(6);
  856.    if RelTblOfs < $40
  857.     then begin
  858.           hS := ($40 + ReloCount * 4 + 15) and $FFFFFFF0;
  859.           S := hS + (PageCount * 512 - (512 - PartPage) - HeaderSize * 16);
  860.           GetMem(P, S); FillChar(P^, S, 0);
  861.           Move(newStub^, P^, RelTblOfs);
  862.           pDosEXEheader(P)^.RelTblOfs := $40;
  863.           pDosEXEheader(P)^.HeaderSize := hS shr 4;
  864.           pDosEXEheader(P)^.PageCount := (S + 511) shr 9;
  865.           pDosEXEheader(P)^.PartPage := S and 511;
  866.           Move(pArrOfByte(newStub)^[RelTblOfs], P^[$40], ReloCount * 4);
  867.           Move(pArrOfByte(newStub)^[HeaderSize * 16], P^[hS], S - hS);
  868.           FreeMem(newStub, newStubSz);
  869.           newStub := P; newStubSz := S;
  870.          end;
  871.   end;
  872. end;
  873.  
  874. Procedure ProcessFiles(const fN : string; Level : Longint);
  875. var sr : SearchRec;
  876.     _d : DirStr;
  877.     _n : NameStr;
  878.     _e : ExtStr;
  879.     nf : Longint;
  880. begin
  881.  ClearProcessed;
  882.  fSplit(fN, _d, _n, _e);
  883.  FindFirst(fN, Archive or Hidden or SysFile, sr);
  884.  if (DosError <> 0) and (Level = 0) and (not Recurse)
  885.   then begin
  886.         textAttr := $0C;
  887.         Writeln('├ Cannot find such files: ', fN);
  888.        end;
  889.  nf := 0;
  890.  While (DosError = 0) and (not allDone) do
  891.   begin
  892.    if not CheckIfProcessed(_d + sr.Name)
  893.     then begin
  894.           Inc(nf);
  895.           if Pause
  896.            then case Ask('File ' + sr.Name + ': [P]rocess, [S]kip or [A]bort?', 'PSA', askConfirm) of
  897.                  2 : sr.Name := '';
  898.                  3 : begin allDone := _ON; break; end;
  899.                 end;
  900.           if (sr.Name <> '') then ProcessFile(_d + sr.Name);
  901.          end;
  902.    FindNext(sr);
  903.   end;
  904.  FindClose(sr);
  905.  if allDone or not Recurse then Exit;
  906.  if nf = 0 then begin textAttr := $0B; Write('└ ', _d); ClrEOL; Write(#13); end;
  907.  FindFirst(_d + '*.*', Archive or Hidden or SysFile or Directory, sr);
  908.  While (dosError = 0) and (not allDone) do
  909.   begin
  910.    if (sr.Attr and Directory <> 0) and (sr.Name[1] <> '.')
  911.     then ProcessFiles(_d + sr.Name + '\' + _n + _e, succ(Level));
  912.    FindNext(sr);
  913.   end;
  914.  FindClose(sr);
  915. end;
  916.  
  917. var I  : longint;
  918.  
  919. begin
  920.  TextAttr := $0F;
  921.  Writeln('┌[ lxLite ]──────────────────────────────[ Version '+Version+' ]┐');
  922.  Writeln('├ Copyright 1996 by FRIENDS software ─ No rights reserved ┘');
  923.  TextAttr := $07;
  924.  @OldExit := ExitProc; ExitProc := @MyExitProc;
  925.  HeapBlock := 64 * 1024;
  926.  New(loadCFG, Init(8));
  927.  New(LX, Init);
  928.  New(Cntry, Init(cyDefault, cpDefault));
  929.  if Cntry = nil then Stop(9);
  930.  New(fNames, Init(8));
  931.  LoadConfig('default');
  932.  ParseCommandLine(#0, ParmHandler, NameHandler);
  933.  if QueryList then begin ShowConfigList; Goto Done; end;
  934.  if (fNames^.numItems = 0) and (not ShowCfg) then Stop(1);
  935.  LoadStub;
  936.  New(pfNames, Init(8));
  937.  if ForceIdle then DosSetPriority(Prtys_ProcessTree, Prtyc_IdleTime, 16, 0);
  938.  if logFileName <> ''
  939.   then begin
  940.         Assign(logFile, logFileName);
  941.         Append(logFile); if ioResult <> 0 then Rewrite(logFile);
  942.         if ioResult <> 0 then Stop(8);
  943.         Writeln(logFile, '-------- ', Cntry^.DateStr(doStdDateL), ' at ',
  944.                 Cntry^.TimeStr(toStdTimeL), ' started lxLite v', Version);
  945.        end;
  946.  
  947.  if doUnpack
  948.   then begin
  949.         objUnpack := _ON;
  950.         PkFlags := PkFlags and not (pkfRunLength or pkfLempelZiv);
  951.        end;
  952.  if ShowCfg then ShowConfig;
  953.  New(exclude, Init(excludeMask));
  954.  
  955.  For I := 1 to fNames^.numItems do
  956.   begin
  957.    ProcessFiles(pString(fNames^.GetItem(I))^, 0);
  958.    if allDone then break;
  959.   end;
  960.  ClrEOL;
  961.  
  962.  freeFnames; Dispose(fNames, Done);
  963.  clearProcessed; Dispose(pfNames, Done);
  964.  Dispose(exclude, Done);
  965.  
  966.  For I := 1 to loadCFG^.numItems do
  967.   DisposeStr(loadCFG^.GetItem(i));
  968.  Dispose(loadCFG, Done);
  969.  Dispose(LX, Done);
  970.  if newStubSz <> -1 then FreeMem(newStub, newStubSz);
  971.  if totalGain <> 0
  972.   then begin
  973.         TextAttr := $03;
  974.         Writeln('├┤Total gain: ', totalGain, ' bytes');
  975.        end;
  976.  if logFileName <> ''
  977.   then Writeln(logFile, '-------- Total gain: ', totalGain, ' bytes');
  978. done:
  979.  TextAttr := $01;
  980.  Writeln('└┤Done');
  981. end.
  982.  
  983.